home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / menace / blt.frm (.txt) next >
Visual Basic Form  |  1997-07-10  |  24KB  |  625 lines
  1. VERSION 5.00
  2. Begin VB.Form frmBlt 
  3.    AutoRedraw      =   -1  'True
  4.    Caption         =   "Menace"
  5.    ClientHeight    =   2055
  6.    ClientLeft      =   60
  7.    ClientTop       =   345
  8.    ClientWidth     =   3030
  9.    KeyPreview      =   -1  'True
  10.    LinkTopic       =   "Form1"
  11.    MousePointer    =   99  'Custom
  12.    ScaleHeight     =   2055
  13.    ScaleWidth      =   3030
  14.    StartUpPosition =   2  'CenterScreen
  15.    Visible         =   0   'False
  16.    Begin VB.Timer Timer1 
  17.       Enabled         =   0   'False
  18.       Interval        =   100
  19.       Left            =   1275
  20.       Top             =   1425
  21.    End
  22. Attribute VB_Name = "frmBlt"
  23. Attribute VB_GlobalNameSpace = False
  24. Attribute VB_Creatable = False
  25. Attribute VB_PredeclaredId = True
  26. Attribute VB_Exposed = False
  27. ' Transparent Blit
  28. Option Compare Text
  29. Option Explicit
  30. Dim u As Long
  31. Dim blnend As Boolean
  32. ' Win32
  33. Const IMAGE_BITMAP = 0
  34. Const LR_LOADFROMFILE = &H10
  35. Const LR_CREATEDIBSECTION = &H2000
  36. Const SRCCOPY = &HCC0020
  37. Private Type BITMAP
  38.         bmType          As Long
  39.         bmWidth         As Long
  40.         bmHeight        As Long
  41.         bmWidthBytes    As Long
  42.         bmPlanes        As Integer
  43.         bmBitsPixel     As Integer
  44.         bmBits          As Long
  45. End Type
  46. ' GDI32
  47. Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
  48. Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
  49. Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
  50. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  51. Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
  52. Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
  53. ' USER32
  54. Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
  55. Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
  56. Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
  57. Private Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long
  58. Const ResolutionX = 640     ' Width for the display mode
  59. Const ResolutionY = 480     ' Height for the display mode
  60. Dim dd As DirectDraw2               ' DirectDraw object
  61. Dim ddsdFront As DDSURFACEDESC      ' Front surface description
  62. Dim ddsFront As DirectDrawSurface2  ' Front buffer
  63. Dim ddsBack As DirectDrawSurface2   ' Back buffer
  64. Dim aDDS As DirectDrawSurface2      ' Images to blit
  65. Dim tDDS As DirectDrawSurface2      ' tiles to blit
  66. Dim ddCaps As DDSCAPS               ' Capabilities for search
  67. Dim fx As DDBLTFX
  68. 'hold the sprites
  69. Dim spnx%(40), spny%(40), spnw%(40), spnh%(40), spnox%(40), spnoy%(40)
  70. Dim mode%      'mode% is the current behaviour
  71. Dim anim%      'amount through the given behaviour animation
  72. Dim animshift% 'flag to indicate if blocks should be pushed during anim
  73. 'dim sprite behaviour guff
  74. Dim bname$(30)  'name of behaviour (arbitrary 30 behaviour limit)
  75. Dim bcells%(30) 'number of cells in the behaviour
  76. Dim bchar%(30, 30) '30 behaviours, with max 30 cells in the anim
  77. Dim bxo%(30, 30)   'x offset
  78. Dim byo%(30, 30)   'y offset
  79. 'now the block array x and y in pixels
  80. Dim blockx%(30)    'up to 30 blocks on a map
  81. Dim blocky%(30)
  82. Dim blockcell%(30)
  83. Dim blockmode%(30) '0=none, 1=left, 2=right, 3=fall
  84. Dim blockcount%    'number of blocks on this level
  85.             
  86. Dim level%
  87. 'hold the map
  88. Dim map(40, 6) As Integer '40 wide, 6 high
  89. Dim mapl%, mapv% 'left margin
  90. ' Loads a bitmap in a DirectDraw surface
  91. Private Function CreateDDSFromBitmap(dd As DirectDraw2, ByVal strFile As String) As DirectDrawSurface2
  92.     Dim hbm As Long                 ' Handle on bitmap
  93.     Dim bm As BITMAP                ' Bitmap header
  94.     Dim ddsd As DDSURFACEDESC       ' Surface description
  95.     Dim dds As DirectDrawSurface2   ' Created surface
  96.     Dim hdcImage As Long            ' Handle on image
  97.     Dim mhdc As Long                ' Handle on surface context
  98.     Dim clr As Long                 'hold the colour top left to be made transparent
  99.     ' Load bitmap
  100.     hbm = LoadImage(ByVal 0&, strFile, IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE Or LR_CREATEDIBSECTION)
  101.     ' Get bitmap info
  102.     GetObject hbm, Len(bm), bm
  103.     ' Fill surface description
  104.     With ddsd
  105.         .dwSize = Len(ddsd)
  106.         .dwFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH
  107.         .DDSCAPS.dwCaps = DDSCAPS_OFFSCREENPLAIN
  108.         .dwWidth = bm.bmWidth
  109.         .dwHeight = bm.bmHeight
  110.     End With
  111.     ' Create surface
  112.     dd.CreateSurface ddsd, dds, Nothing
  113.     ' Create memory device
  114.     hdcImage = CreateCompatibleDC(ByVal 0&)
  115.     ' Select the bitmap in this memory device
  116.     SelectObject hdcImage, hbm
  117.     ' Restore the surface
  118.     dds.Restore
  119.     ' Get the surface's DC
  120.     dds.GetDC mhdc
  121.     ' Copy from the memory device to the DirectDrawSurface
  122.     StretchBlt mhdc, 0, 0, ddsd.dwWidth, ddsd.dwHeight, hdcImage, 0, 0, bm.bmWidth, bm.bmHeight, SRCCOPY
  123.     'get the top left colour
  124.     clr = GetPixel(mhdc, 0, 0)
  125.     ' Release the surface's DC
  126.     dds.ReleaseDC mhdc
  127.     ' Release the memory device and the bitmap
  128.     DeleteDC hdcImage
  129.     DeleteObject hbm
  130.     'make surface transparent
  131.     Dim mhddck As DDCOLORKEY
  132.     mhddck.dwColorSpaceLowValue = clr 'really works only for 24 bit colour
  133.     mhddck.dwColorSpaceHighValue = clr 'but as sprites have black is all 0 at any rate
  134.     dds.SetColorKey DDCKEY_SRCBLT, mhddck
  135.     ' Returns the new surface
  136.     Set CreateDDSFromBitmap = dds
  137. End Function
  138. Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
  139. If mode% = 1 Or mode% = 2 Then 'walking left or right
  140.     'shift = 1 then push, = 2 then jump
  141.     Select Case KeyCode
  142.         Case vbKeyR
  143.             'restart  the level
  144.             loadlevel level%
  145.         Case vbKeyControl
  146.             Select Case Shift
  147.             Case 2
  148.                 If mode% = 1 Then mode% = 5 Else mode% = 7 'jump
  149.                 anim% = 0 'amount through the jump
  150.                 animshift% = 0 'don't shift blocks
  151.             Case 3 'jump & shift
  152.                 If mode% = 1 Then mode% = 5 Else mode% = 7 'jump
  153.                 anim% = 0 'amount through the jump
  154.                 animshift% = 1 'shift blocks
  155.             End Select
  156.         Case vbKeyEscape
  157.             blnend = True
  158.         Case vbKeyLeft
  159.             Select Case Shift
  160.             Case 0 'walk normally
  161.                 mode% = 1 'walkleft
  162.                 anim% = anim% + 1 'walk
  163.                 If anim% > 7 Then anim% = 1
  164.                 If map((mapl% + 294) \ 60, mapv% \ 60) = 0 Then
  165.                     mapl% = mapl% - 6
  166.                 End If
  167.                 If mapl% < -300 Then mapl% = -300
  168.                 If mapl% Mod 60 = 0 Then
  169.                     If map((mapl% + 300) \ 60, (mapv% + 10) \ 60) = 0 Then
  170.                         mode% = 3 'fallleft
  171.                     End If
  172.                 End If
  173.             Case 1 'shift box
  174.                 mode% = 9 'shift left
  175.                 anim% = 0 'amount through the jump
  176.                 animshift% = 1 'shift blocks
  177.             End Select
  178.         Case vbKeyRight
  179.             Select Case Shift
  180.             Case 0 'walk normally
  181.                 mode% = 2 'walkright
  182.                 anim% = anim% + 1 'walk
  183.                 If anim% > 7 Then anim% = 1
  184.                 If map((mapl% + 365) \ 60, mapv% \ 60) = 0 Then
  185.                     mapl% = mapl% + 6
  186.                 End If
  187.                 If mapl% > 2400 Then mapl% = 2400
  188.                 If mapl% Mod 60 = 0 Then
  189.                     If map((mapl% + 300) \ 60, (mapv% + 10) \ 60) = 0 Then
  190.                         mode% = 4 'fall
  191.                     End If
  192.                 End If
  193.             Case 1 'shift box
  194.                 mode% = 10 'shift right
  195.                 anim% = 0 'amount through the jump
  196.                 animshift% = 1 'shift blocks
  197.             End Select
  198.     End Se